home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / menu.lisp < prev    next >
Lisp/Scheme  |  1991-08-07  |  34KB  |  1,045 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       make-menu
  25.       menu
  26.       menu-choice
  27.       menu-title
  28.       )
  29.     'clio-open)
  30.  
  31.  
  32. ;================================================================;
  33. ;                   THE PUSHPIN CONTACT           ;
  34. ;================================================================;
  35.  
  36.  
  37.  
  38.  
  39.  
  40. (defcontact pushpin-button (button)
  41.   ((pointer-pressed   :type      boolean
  42.               :initform  nil))
  43.   (:resources
  44.     (border-width :initform 0)
  45.     
  46.     (switch       :type (member :in :out)
  47.           :initform :out)))
  48.  
  49. (defun make-pushpin-button (&rest initargs)
  50.   (apply #'make-contact 'pushpin-button initargs))
  51.  
  52.  
  53.  
  54. (defvar ol-last-scale '())      ;These state variables are used to cache the menu spec for the
  55. (defvar ol-last-spec '())      ;most recent scale requested.
  56.  
  57. (defun get-OL-menu-spec (self)
  58.   (declare (type (or NULL contact) self))
  59.   (if (null self)
  60.       (setf ol-last-scale NIL)        ;This is just in case anyone ever needs to reset state
  61.       (let ((this-scale (contact-scale self)))
  62.     (if (eq this-scale ol-last-scale)
  63.         ol-last-spec
  64.         (let ((spec (cdr (assoc this-scale *OL-menu-spec-alist*))))
  65.           (setf ol-last-scale this-scale)
  66.           (setf ol-last-spec spec))))))
  67.  
  68. (defun get-pushpin-spec (self)
  69.   (declare (type pushpin-button self))
  70.   (OL-menu-spec-pushpin (get-OL-menu-spec self)))
  71.   
  72.  
  73. (defmethod initialize-instance :after ((self pushpin-button)
  74.                        &key switch &allow-other-keys)
  75.  
  76.   (with-slots (border-width selected) self
  77.     (setf border-width 0)
  78.  
  79.     (when (eq switch :in)
  80.       (setf selected 2))))
  81.  
  82.  
  83.  
  84.  
  85.  
  86. (DEFMETHOD preferred-size ((self pushpin-button) &key width height border-width)
  87.   (declare (ignore width height border-width))
  88.   
  89.   (DECLARE (VALUES preferred-width preferred-height
  90.            preferred-border-width))
  91.   (let*
  92.     ((menu-spec (get-OL-menu-spec self))
  93.      (pushpin-spec (OL-menu-spec-pushpin menu-spec)))
  94.     
  95.     (with-slots (preferred-width) self
  96.       (VALUES                      
  97.     (OR preferred-width
  98.         (SETF preferred-width
  99.           (+ (pushpin-spec-box-width pushpin-spec)
  100.              (- (OL-menu-spec-pushpin-dx menu-spec)    ;Spec left margin
  101.             (pushpin-spec-left-margin pushpin-spec)))))    ;Account for (possible) padding in image
  102.     (+ (OL-menu-spec-pushpin-dy menu-spec)    ;menu top to pushpin baseline distance
  103.        (OL-menu-spec-title-bar-dy menu-spec))    ;pushpin (title) baseline to title bar
  104.     0))))
  105.  
  106.  
  107.  
  108. ;;; =================================================================================== ;;;
  109. ;;;                                            ;;;
  110. ;;;                              Display a Pushpin Button...                ;;;
  111. ;;;                                            ;;;
  112. ;;; =================================================================================== ;;;
  113.  
  114. (defmethod display-pushpin-button ((self pushpin-button) menu-spec spec 
  115.                    &optional completely-p)
  116.   (with-slots (font background foreground width height label)
  117.     self
  118.     (WHEN (realized-p self)            
  119.       (using-gcontext (gc
  120.                :drawable     self
  121.                :exposures  :off
  122.                ;;                :foreground foreground
  123.                ;;                :background background
  124.                :font     font
  125.                :line-width    1)
  126.         
  127.      (WHEN completely-p
  128.        (clear-area self
  129.                :x 0
  130.                :y 0
  131.                :width  width
  132.                :height height))
  133.           
  134.  
  135.      (let* ((lab-width (drawable-width label))
  136.         (lab-height (drawable-height label))
  137.         (x (- (OL-menu-spec-pushpin-dx menu-spec) ;desired dx to left of pin
  138.               (pushpin-spec-left-margin spec)))      ;left margin padding in pixmap
  139.         (y (- (OL-menu-spec-pushpin-dy menu-spec) ;desired baseline relative menu
  140.               (pushpin-spec-baseline spec)      ;pin baseline relative box
  141.               (pushpin-spec-top-margin spec))))      ;top margin padding in pixmap
  142.        (copy-area label gc 0 0 lab-width lab-height self x y)
  143.        )))))
  144.  
  145.  
  146. (DEFMETHOD display-button-highlighted ((self pushpin-button) &optional completely-p)
  147.   (with-slots (last-displayed-as label)
  148.     self
  149.     (let*
  150.     ((menu-spec (get-OL-menu-spec self))
  151.      (spec (OL-menu-spec-pushpin menu-spec))
  152.      (screen (contact-screen self)))
  153.       (setf label
  154.         (contact-image-mask
  155.          self
  156.          (pushpin-spec-image-in spec)
  157.          :foreground (screen-black-pixel screen)
  158.          :background (screen-white-pixel screen)))
  159.       (display-pushpin-button self menu-spec spec completely-p))
  160.     (SETF last-displayed-as :highlighted)))
  161.  
  162.  
  163. (DEFMETHOD display-button-unhighlighted ((self pushpin-button) &optional completely-p)
  164.   (with-slots (last-displayed-as highlight-default-p label)
  165.     self
  166.     (let*
  167.     ((menu-spec (get-OL-menu-spec self))
  168.      (spec (OL-menu-spec-pushpin menu-spec))
  169.      (screen (contact-screen self)))
  170.       (setf label
  171.         (contact-image-mask
  172.          self
  173.          (pushpin-spec-image-out spec)
  174.          :foreground (screen-black-pixel screen)
  175.          :background (screen-white-pixel screen)))
  176.       (display-pushpin-button self menu-spec spec completely-p))
  177.     (SETF last-displayed-as :unhighlighted)))
  178.  
  179. ;;; NOTE: The following choice item methods for pushpins should invoke the choice 
  180. ;;; item callbacks, but I haven't done this yet.
  181.  
  182. (defmethod choice-item-press ((pushpin-button pushpin-button))
  183.   (with-slots (selected) pushpin-button
  184.     (LET((to-selected-p (= selected 1)))
  185.       (SETF selected (- selected))
  186.       (IF to-selected-p
  187.       (display-button-highlighted pushpin-button)
  188.       (display-button-unhighlighted pushpin-button))
  189.       T)))
  190.  
  191. (defmethod choice-item-release ((pushpin-button pushpin-button))
  192.   (with-slots (selected) pushpin-button
  193.     (apply-callback pushpin-button 
  194.             (IF (= 2 (SETF selected (+ 3 selected))) :on :off))))
  195.  
  196. (defmethod choice-item-leave ((pushpin-button pushpin-button))
  197.   (display-button-unhighlighted pushpin-button))
  198.  
  199. (defmethod menu-leave-pushpin-button ((self pushpin-button))
  200.    (declare (type pushpin-button self))
  201.    (with-slots (pointer-pressed) self
  202.      (when pointer-pressed
  203.        (choice-item-leave self)
  204.        (setq pointer-pressed nil))))
  205.  
  206. (defmethod menu-release-pushpin-button ((self pushpin-button))
  207.    (declare (type pushpin-button self))
  208.  
  209.    ;; Eventually this is where the logic associated with pinning a menu will exist.
  210. ;     (format t "~%Sorry - Pinning of menus not yet implemented.")
  211. ;     ;; For now we treat a release just like a leave 'cause pinning
  212. ;     ;; isn't implemented yet.
  213. ;     (menu-leave-pushpin-button self)
  214.  
  215.    ;;  +++ For now we hack pushpins to just change the pushpin state, and let
  216.    ;;      menu-dismissal fake pinning by not dismissing if the pushpin is in.
  217.    ;;      So, do press-and-release and delete the events.
  218.    (with-slots (pointer-pressed) self
  219.      (when pointer-pressed
  220.        (choice-item-release self)
  221.        (setq pointer-pressed nil))))
  222.  
  223. (DEFMETHOD press-select ((self pushpin-button))
  224.    (WHEN (choice-item-press self)
  225.      (with-slots (pointer-pressed) self
  226.        (setq pointer-pressed t))))
  227.  
  228. (DEFMETHOD release-select ((self pushpin-button))
  229.    (with-event (state)
  230.      (with-slots (selected pointer-pressed) self
  231.        (WHEN (AND (> 0 selected)
  232.           (NOT (ZEROP (LOGAND #.(make-state-mask :button-1) state))))
  233.      (UNWIND-PROTECT 
  234.          (choice-item-release self)
  235.        (setq pointer-pressed nil))))))
  236.  
  237. (DEFMETHOD menu-enter-pushpin-button ((self pushpin-button))
  238.    (with-event (state)
  239.      (unless (zerop (logand #.(make-state-mask :button-3) state))
  240.        (when (choice-item-press self)
  241.      ;(display-button-highlighted self)
  242.      (with-slots (pointer-pressed) self
  243.        (setq pointer-pressed t))))))
  244.  
  245. (DEFMETHOD (SETF choice-item-selected-p) (new-value (self pushpin-button))
  246.    ;; Identical to (SETF button-switch) except returns boolean in/out indicator.
  247.    (DECLARE (VALUES new-value))
  248.    (EQ (SETF (button-switch self) (if new-value :in :out)) :in))
  249.  
  250. ;;; ========================================================================== ;;;
  251. ;;;                                           ;;;
  252. ;;;        ( P u s h p i n )   B u t t o n   P r o t o c o l   M e t h o d s   ;;;
  253. ;;;                                           ;;;
  254. ;;; ========================================================================== ;;;
  255.  
  256. (DEFMETHOD button-switch ((self pushpin-button))
  257.    (with-slots (selected) self
  258.      (NTH (1- (ABS selected)) '(:out :in))))
  259.  
  260. (DEFMETHOD (SETF button-switch) (new-state (self pushpin-button))
  261.    (check-type new-state (member :in :out))
  262.    (LET ((current-state (button-switch self)))
  263.      (WHEN (NOT (EQ current-state new-state))
  264.        ;; We simulate a button press and release to implement identical
  265.        ;; semantics whether done via API or via gesture.
  266.        (WHEN (choice-item-press self)
  267.      ;; When toggle press succeeded we follow it
  268.      ;; with a release.
  269.      (choice-item-release self)))
  270.      (button-switch self)))
  271.  
  272.  
  273. (DEFEVENT pushpin-button
  274.       :enter-notify
  275.         menu-enter-pushpin-button)
  276.  
  277. (defevent pushpin-button
  278.       :leave-notify
  279.    menu-leave-pushpin-button)
  280.  
  281. (defevent pushpin-button
  282.       (:button-release :button-1)
  283.    pp-maybe-release-select)
  284.  
  285. (defun pp-maybe-release-select (button)
  286.    (with-slots (pointer-pressed) (the pushpin-button button)
  287.      (when pointer-pressed
  288.        (release-select button))))
  289.  
  290. ;;  These two translations are for Open Look menus, which allow item selection
  291. ;;  on both button-1 and button-3 presses.
  292. (DEFEVENT pushpin-button
  293.       (:button-press :button-3)
  294.    press-select)
  295.  
  296. (DEFEVENT pushpin-button
  297.       (:button-release :button-3)
  298.    menu-release-pushpin-button)
  299.  
  300.  
  301. ;================================================================;
  302. ;               MENU  CONTACT             ;
  303. ;================================================================;
  304.  
  305. (defcontact menu (core-shell core override-shell)
  306.   ()
  307.   (:resources
  308.     (title       :type     (or null string)
  309.             :initform nil)
  310.     (pushpin      :type     switch
  311.           :initform :off)
  312.     (save-under   :initform :on)
  313.     (border-width :initform 0))
  314.   (:documentation "A shell which presents a set of choice items."))
  315.   
  316. (defun make-menu (&rest initargs)
  317.   "Creates and returns a menu instance."
  318.   (declare (values menu)) 
  319.   (apply #'make-contact 'menu initargs))
  320.  
  321. (defmethod initialize-instance :after ((menu menu) &rest args
  322.                        &key (choice 'make-choices) &allow-other-keys)
  323.   (with-slots (background border-width width height) menu    
  324.  
  325. ;;  Can't do this now that the choice arg is a constructor rather than a type.
  326. ;    (let ((choice-class (if (consp choice) (first choice) choice))) 
  327. ;      (assert (subtypep choice-class 'composite) nil
  328. ;          "~s is not a composite subclass name." choice-class)) 
  329.     
  330.     (apply #'make-contact
  331.        'drop-shadow
  332.        :parent menu
  333.        :x 0
  334.        :y 0
  335.        :width width
  336.        :height height
  337.        :content choice
  338.        args)
  339.  
  340.     ;; Now that content is created with initial attributes,
  341.     ;; reset background, border-width to accommodate drop-shadow.
  342.     (setf background   :none
  343.       border-width 0)))
  344.  
  345. ;;  When asked for background, give the background of the container.
  346. (defmethod contact-background ((menu menu))
  347.    (with-slots (children) menu
  348.      (let ((container (and children (menu-container menu))))
  349.        (if container
  350.        (contact-background container)
  351.        :none))))
  352.  
  353. (defmethod (setf contact-background) (new-value (menu menu))
  354.   (setf (contact-background (menu-container menu)) new-value))
  355.  
  356. (defmethod (setf contact-foreground) (new-value (menu menu))
  357.   (setf (contact-foreground (menu-container menu)) new-value))
  358.  
  359. (defmethod menu-choice ((menu menu))
  360.   (find :content (composite-children (menu-container menu)) :key #'contact-name))
  361.  
  362. (defun menu-container (menu)
  363.   (first (composite-children (first (composite-children menu)))))
  364.  
  365. (defmethod (setf menu-title) (new-title (menu menu))
  366.   (let
  367.     ((title-field (find :menu-title
  368.             (composite-children (menu-container menu))
  369.             :key 'contact-name))
  370.      (title       (convert menu new-title 'string)))
  371.     
  372.     (assert title nil "~a cannot be converted to a title string." new-title)
  373.  
  374.     (cond
  375.       (title-field
  376.        (change-geometry
  377.      title-field
  378.      :width    (text-width (display-text-font title-field) title)
  379.      :accept-p t)       
  380.        (setf (display-text-source title-field) title))
  381.  
  382.       (t
  383.        (make-display-text-field
  384.       :name            :menu-title
  385.       :parent          (menu-container menu)
  386.       :display-gravity :center
  387.       :source          title)))
  388.     title))
  389.  
  390. (defmethod menu-title ((menu menu))
  391.   (let ((title-field (find :menu-title
  392.                (composite-children (menu-container menu))
  393.                :key 'contact-name)))
  394.     (when title-field
  395.       (display-text-source title-field))))
  396.  
  397.  
  398. (defmethod preferred-size ((self menu) &key width height border-width)
  399.   (declare (ignore width height border-width))
  400.  
  401.   (declare (values preferred-width preferred-height
  402.            preferred-border-width))
  403.   (preferred-size (first (composite-children self))))
  404.  
  405.  
  406. (defmethod shell-mapped ((self menu))
  407.   "Invokes :initialize callback function."
  408.   (apply-callback self :map)
  409.   (apply-callback-else (self :initialize)
  410.     (with-slots ((members children)) (menu-choice self)
  411.       (dolist (member members)
  412.     (apply-callback member :initialize)))))
  413.  
  414.  
  415. ;================================================================;
  416. ;            DROP SHADOW CONTACT             ;
  417. ;================================================================;
  418.  
  419. (defcontact drop-shadow (core composite)
  420.   ((compress-exposures :initform :on))
  421.   (:documentation "A composite containing a content and a drop-shadow.")
  422.   (:resources (event-mask :initform #.(make-event-mask :exposure))))
  423.  
  424. (defmethod initialize-instance :after ((drop-shadow drop-shadow) &rest args)
  425.   (with-slots (background border-width) drop-shadow
  426.     ;; Ignore background, border-width
  427.     (setf background :none)
  428.     (setf border-width 0))
  429.  
  430.   ;; Make the menu container to hold the content, title, & pushpin components.
  431.   (apply #'make-contact 'menu-container
  432.     :name :menu-container
  433.     :parent drop-shadow
  434.     args))
  435.  
  436. (defmethod preferred-size ((self drop-shadow) &key width height border-width)
  437.   (declare (ignore width height border-width))
  438.   (let*
  439.     ((spec (get-OL-menu-spec self))
  440.      (dsw (OL-menu-spec-drop-shadow-width spec)))
  441.     (multiple-value-bind (pw ph pbw)
  442.     (preferred-size (first (composite-children self)))
  443.       (values
  444.     (+ dsw pbw pbw pw)
  445.     (+ dsw pbw pbw ph)
  446.     0))))
  447.  
  448. (defmethod display ((drop-shadow drop-shadow) &optional x y width height &key)
  449.   (declare (ignore x y width height))
  450.   (with-slots (children) drop-shadow
  451.     (when children
  452.       (with-slots (width height border-width) (first children)
  453.     (let*
  454.       ((spec (get-OL-menu-spec drop-shadow))
  455.        (dsw (OL-menu-spec-drop-shadow-width spec))
  456.        (dso (OL-menu-spec-drop-shadow-offset spec))
  457.        (menu-container-width (+ width border-width border-width))
  458.        (menu-container-height (+ height border-width border-width)))
  459.       (using-gcontext (gc :drawable drop-shadow
  460.                   :foreground (contact-foreground drop-shadow)
  461.                   :fill-style :stippled
  462.                   :stipple (contact-image-mask drop-shadow 50%gray :depth 1))
  463.             ;; We draw a full rectangle, depending on the server to clip the
  464.         ;; portion covered by the menu container.
  465.         (draw-rectangle drop-shadow gc
  466.                         dso dso
  467.                 (- (+ menu-container-width dsw) dso)
  468.                 (- (+ menu-container-height dsw) dso)
  469.                 :fill-p)))))))
  470.  
  471. (defmethod manage-geometry ((self drop-shadow) child x y width height border-width &key)
  472.   (let*
  473.     ((spec (get-OL-menu-spec self))
  474.      (dsw (OL-menu-spec-drop-shadow-width spec))
  475.      (child-bw (or border-width (contact-border-width child)))
  476.      (width (or width (contact-width child)))
  477.      (height (or height (contact-height child)))
  478.      (drop-shadow-contact-width (+ width child-bw child-bw dsw))
  479.      (drop-shadow-contact-height (+ height child-bw child-bw dsw))
  480.  
  481.      (self-change-not-required-p
  482.        (and (= (contact-width self) drop-shadow-contact-width)
  483.         (= (contact-height self) drop-shadow-contact-height)))
  484.      (approved-p
  485.        (and
  486.      (or (null x) (= x 0))
  487.      (or (null y) (= y 0))
  488.      (or self-change-not-required-p
  489.          (change-geometry self
  490.                   :width drop-shadow-contact-width
  491.                   :height drop-shadow-contact-height
  492.                   :accept-p t)))))
  493.  
  494.     (values
  495.       approved-p
  496.       0 0
  497.       (- (contact-width self) child-bw child-bw dsw)
  498.       (- (contact-height self) child-bw child-bw dsw)
  499.       child-bw)))
  500.  
  501. (defmethod change-layout ((self drop-shadow) &optional newly-managed)
  502.   (declare (ignore newly-managed))
  503.   (let((children (composite-children self)))
  504.     (when children
  505.       (let*
  506.     ((spec (get-OL-menu-spec self))
  507.      (dsw (OL-menu-spec-drop-shadow-width spec))
  508.      (menu-container (first children))
  509.      (border-width (contact-border-width menu-container))
  510.      (width (contact-width menu-container))
  511.      (height (contact-height menu-container)))
  512.     (change-geometry
  513.       self
  514.       :width (+ width border-width border-width dsw)
  515.       :height (+ height border-width border-width dsw)
  516.       :accept-p t)))))
  517.  
  518. (defmethod add-child :before ((self drop-shadow) child &key)
  519.   (let((children (composite-children self)))
  520.     (when children
  521.       (error "~s already has child ~s; cannot add child ~s."
  522.          self
  523.          (first children)
  524.          child))))
  525.  
  526. (defmethod resize :after ((self drop-shadow) width height border-width)
  527.   (declare (ignore border-width))
  528.   (let*
  529.     ((children (composite-children self))
  530.      (menu-container (first children))
  531.      (spec (get-OL-menu-spec self))
  532.      (dsw (OL-menu-spec-drop-shadow-width spec))
  533.      (bw (contact-border-width menu-container)))
  534.     (resize menu-container
  535.         (max 1 (- width bw bw dsw))
  536.         (max 1 (- height bw bw dsw))
  537.         bw)))
  538.     
  539.  
  540. ;================================================================;
  541. ;            MENU-CONTAINER CONTACT             ;
  542. ;================================================================;
  543.  
  544. (defcontact menu-container (core composite)
  545.   ((compress-exposures :initform :on))
  546.   (:resources
  547.     (event-mask :initform #.(make-event-mask :exposure)))
  548.   (:documentation 
  549.     "A composite containing a content and (optionally) a title and pushpin"))
  550.  
  551. (defmethod initialize-instance :after ((self menu-container)
  552.                        &rest args
  553.                        &key content (pushpin :off) title
  554.                        &allow-other-keys) 
  555.  
  556.   (let ((menu      (contact-parent (contact-parent self)))
  557.     (menu-spec (get-OL-menu-spec self)))
  558.  
  559.     ;; Initialize container window attributes.
  560.     (with-slots (background border-width) self
  561.       ;; Inherit background from menu, not drop-shadow.
  562.       (when (eq :parent-relative background)
  563.     (setf background (contact-current-background menu)))
  564.  
  565.       ;; Inherit border-width from menu
  566.       (setf border-width (max (contact-border-width menu)
  567.                   (point-pixels (contact-screen self)))))
  568.       
  569.       
  570.       ;; Initialize content
  571.       (multiple-value-bind (content-constructor content-args)
  572.       (if (consp content) (values (first content) (rest content)) content)
  573.     
  574.     (add-callback
  575.       (if (null content-args)
  576.           
  577.           ;; Default choice initialization 
  578.           (funcall content-constructor
  579.         :name          :content
  580.         :parent        self
  581.         :border-width  0 
  582.         :left-margin   (OL-menu-spec-pushpin-dx menu-spec)
  583.         :right-margin  (OL-menu-spec-pushpin-dx menu-spec)
  584.         :bottom-margin (OL-menu-spec-drop-shadow-offset menu-spec) 
  585.         :top-margin    (OL-menu-spec-drop-shadow-offset menu-spec)
  586.         :columns       1
  587.         :same-width-in-column :on)
  588.           
  589.           ;; Else use given content initargs
  590.           (apply content-constructor
  591.              :name          :content
  592.              :parent        self
  593.              :border-width  0 
  594.              content-args))
  595.       
  596.       :new-choice-item
  597.       #'add-menu-item-callbacks menu))
  598.  
  599.       ;; Initialize title field
  600.       (when title
  601.     (setf (menu-title menu) title))
  602.  
  603.       ;; Initialize pushpin
  604.       (when (eq pushpin :on)
  605.     (add-callback
  606.       (make-pushpin-button
  607.         :name :pushpin
  608.         :parent self
  609.         :label (pushpin-spec-image-out (get-pushpin-spec self)))
  610.       :off
  611.       #'dismiss-menu menu))))
  612.  
  613. ;;  A method so dialog-button can add daemons.
  614. (defmethod add-menu-item-callbacks (item menu)
  615.    (when (typep item 'toggle-button)
  616.      (add-callback item :on #'dismiss-menu menu))
  617.    (add-callback item :off #'dismiss-menu menu))
  618.  
  619. (defun dismiss-menu (menu)
  620.    (unless (eq (contact-state menu) :withdrawn)    ;i.e., already dismissed
  621.      ;;  +++ Pushpin hack:  If the menu has a pushpin and it's :in, don't
  622.      ;;      withdraw the menu.  It doesn't clone, but it does stay up.
  623.      (let ((pushpin (find :pushpin (composite-children
  624.                      (contact-parent (menu-choice menu)))
  625.               :key #'contact-name)))
  626.        (unless (and pushpin
  627.             (eq :in (button-switch pushpin)))
  628.      (setf (contact-state menu) :withdrawn)))))
  629.      
  630.  
  631. (defmethod display ((self menu-container)
  632.             &optional exposed-x exposed-y exposed-width exposed-height &key)
  633.   (declare (ignore exposed-x exposed-y exposed-width exposed-height))
  634.   (with-slots (children width foreground) self
  635.     (when (find :menu-title children :key #'contact-name)
  636.       (let ((tbar-x 4) ; Kludge! this is actually a function of scale.
  637.         (tbar-y (- (contact-y (find :content children :key #'contact-name)) 1)))
  638.     (using-gcontext (gc :drawable self :foreground foreground)
  639.       (draw-line self gc tbar-x tbar-y (- width tbar-x) tbar-y))))))    
  640.  
  641.  
  642. ;================================================================;
  643. ;          MENU-CONTAINER GEOMETRY MANAGEMENT         ;
  644. ;================================================================;
  645.  
  646. (defun mcgm-disapprove () NIL)
  647.    
  648. (defun mcgm-fail () (error "Unable to layout menu-container." ))
  649.  
  650. (defun shrink/expand-title (title pw ph tw th cw ch failure-thunk)
  651.   (multiple-value-bind (tw1 th1)
  652.       (preferred-size title :width 0 :height 0)
  653.     (if (<= tw1 tw)
  654.     ;; We assume it's OK to make title *wider* than preferred width,
  655.     ;; but avoid making it narrower.
  656.     (values
  657.      (+ 2 (max (or (and pw tw (+ pw
  658.                      (ol-menu-spec-title-dx (get-ol-menu-spec title))
  659.                      (ol-menu-spec-title-dx (get-ol-menu-spec title))
  660.                      tw))
  661.                (and tw
  662.                 (+ tw
  663.                    (ol-menu-spec-title-dx (get-ol-menu-spec title))
  664.                    (ol-menu-spec-title-dx (get-ol-menu-spec title))))
  665.                0)
  666.            (+ cw (ol-menu-spec-title-dx (get-ol-menu-spec title))
  667.               (ol-menu-spec-title-dx (get-ol-menu-spec title))))) ;Allow 2 pixels for left & right border
  668.      (+ 2                          ;Allow 2 pixels for top & bottom border
  669.         (or (and ph (max ph th1)) th1)
  670.         1                          ;Allow 1 pixel for title bar
  671.         ch)
  672.      pw
  673.      ph
  674.      tw
  675.      th
  676.      cw
  677.      ch)
  678.     (funcall failure-thunk))))
  679.  
  680. (defun shrink/expand-content (content pw ph tw th cw ch failure-thunk)
  681.   (multiple-value-bind (cw1 ch1)
  682.       (preferred-size content :width 0 :height 0) 
  683.     (if (<= cw1 cw)
  684.     ;; We assume it's OK to make content *wider* than preferred width,
  685.     ;; but avoid making it narrower.
  686.     (values
  687.      (+ 2 (max (or (and pw tw (+ pw
  688.                      (ol-menu-spec-title-dx (get-ol-menu-spec content))
  689.                      (ol-menu-spec-title-dx (get-ol-menu-spec content))
  690.                      tw))
  691.                (and tw
  692.                 (+ tw
  693.                    (ol-menu-spec-title-dx (get-ol-menu-spec content))
  694.                    (ol-menu-spec-title-dx (get-ol-menu-spec content))))
  695.                0)
  696.            (+ cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
  697.               (ol-menu-spec-title-dx (get-ol-menu-spec content)))
  698.            ))                      ;Allow 2 pixels for left & right border ;; jba 
  699.      (+ 2                          ;Allow 2 pixels for top & bottom border
  700.         (or (and ph th (max ph th)) ph th 0)
  701.         (if th 1 0)                      ;Title bar only if title
  702.         ch1)
  703.      pw
  704.      ph
  705.      tw
  706.      th
  707.      cw1
  708.      ch)
  709.     (funcall failure-thunk))))
  710.  
  711. (defun reposition&resize (component cx cy cw ch)
  712.   (let
  713.       ((x (contact-x component))
  714.        (y (contact-y component))
  715.        (w (contact-width component))
  716.        (h (contact-height component)))
  717.     (unless (and (= x cx) (= y cy)) (move component cx cy))
  718.     (unless (and (= w cw) (= h ch)) (resize component cw ch 0))))
  719.     
  720. (defun execute-layout (self width height ppin pw ph title tw th content cw ch) 
  721.   (assert
  722.    (change-geometry self :width width :height height)
  723.    ()
  724.    "Unable to layout menu ~a" self)
  725.     
  726.   (multiple-value-bind (px py tx ty cx cy)
  727.       (locate-menu-components pw ph tw th width self)
  728.     (when ppin (reposition&resize ppin px py pw ph))
  729.     (when title 
  730.       (reposition&resize title tx ty tw th))
  731.     (when content (reposition&resize content cx cy cw ch))) )
  732.  
  733. (defun locate-menu-components (pw ph tw th width self) 
  734.   (cond
  735.     ((and pw tw)
  736.      (values
  737.       0 0                          ; x & y for pushpin
  738.       (+ pw (ol-menu-spec-title-dx (get-ol-menu-spec self)) ) 0    ; x & y for title
  739.       (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
  740.        (pixel-round (- width
  741.                (contact-width (find :content (composite-children self) :key #'contact-name)))
  742.             2))
  743.       (+ (max ph th) 1)))                  ;x & y for content
  744.     (pw
  745.      (values
  746.       0 0
  747.       NIL NIL
  748.       (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
  749.        (pixel-round (- width
  750.                (contact-width (find :content (composite-children self) :key #'contact-name)))
  751.             2))
  752.       ph))
  753.     (tw
  754.      (values
  755.       NIL NIL 
  756.       (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
  757.        (pixel-round (- width
  758.                (contact-width (find :menu-title (composite-children self) :key #'contact-name)))
  759.             2))
  760.       0
  761.       (max (ol-menu-spec-title-dx (get-ol-menu-spec self))
  762.        (pixel-round (- width
  763.                (contact-width (find :content (composite-children self) :key #'contact-name)))
  764.             2))
  765.       (+ 1 th)))
  766.     (t
  767.      (values
  768.       NIL NIL
  769.       NIL NIL
  770.       0 0))))
  771.       
  772. (defun layout-menu-container (ppin pw ph title tw th content cw ch) 
  773.   (cond
  774.     ((and title ppin)
  775.                               ; Menu has title and pushpin in addition to content
  776.      (let ((title-area-height (max ph th)))
  777.        (if (= (+ tw pw) cw)
  778.        (values
  779.         (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
  780.            (ol-menu-spec-title-dx (get-ol-menu-spec content)))
  781.         (+ 2 title-area-height 1 ch)
  782.         pw title-area-height
  783.         tw title-area-height
  784.         cw ch)
  785.        ;; We must expand/shrink title or shrink/expand content.
  786.        (let((newtw (- cw pw)))
  787.          (if (< newtw 0)
  788.          (shrink/expand-content content pw ph tw th (+ tw pw) ch #'mcgm-fail)
  789.          (shrink/expand-title
  790.           title
  791.           pw
  792.           title-area-height
  793.           newtw
  794.           title-area-height
  795.           cw
  796.           ch
  797.           #'(lambda()
  798.               (shrink/expand-content
  799.                content
  800.                pw
  801.                title-area-height
  802.                tw
  803.                title-area-height
  804.                (+ tw pw)              ; Will fail when title is bigger, so width is title width.
  805.                ch
  806.                #'mcgm-fail))))))))
  807.        
  808.     (title
  809.                               ;Menu has title, but no pushpin
  810.      (if (= tw cw)
  811.      (values
  812.       (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
  813.          (ol-menu-spec-title-dx (get-ol-menu-spec content)))
  814.       (+ 2 th 1 ch)
  815.       pw ph
  816.       tw th
  817.       cw ch)
  818.      (shrink/expand-title
  819.       title
  820.       pw
  821.       ph
  822.       tw
  823.       th
  824.       cw
  825.       ch
  826.       #'(lambda()
  827.           (shrink/expand-content content pw ph tw th tw ch #'mcgm-fail)))
  828.      ))
  829.        
  830.     (ppin
  831.                               ;Menu has pushpin, but no title
  832.      (if (> cw pw)
  833.      (values (+ 2 cw (ol-menu-spec-title-dx (get-ol-menu-spec content))
  834.             (ol-menu-spec-title-dx (get-ol-menu-spec content)))
  835.          (+ 2 ph ch) pw ph tw th cw ch)
  836.      (shrink/expand-content content pw ph tw th pw ch #'mcgm-fail)))
  837.        
  838.     (t
  839.                               ;Menu has neither pushpin nor title
  840.      (values (+ 2 cw) (+ 2 ch) pw ph tw th cw ch))))
  841.  
  842.  
  843. (defmethod change-layout ((self menu-container) &optional newly-managed)
  844.   (declare (ignore newly-managed))
  845.   (let* ((children (composite-children self))
  846.        
  847.      (content (find :content children :key #'contact-name))
  848.      (cw (contact-width content))
  849.      (ch (contact-height content))
  850.        
  851.      (title (find :menu-title children :key #'contact-name))
  852.      (tw (and title (contact-width title)))
  853.      (th (and title (contact-height title)))
  854.        
  855.      (ppin (find :pushpin children :key #'contact-name))
  856.      (pw (and ppin (contact-width ppin)))
  857.      (ph (and ppin (contact-height ppin))))
  858.     (multiple-value-bind (width height pw1 ph1 tw1 th1 cw1 ch1)
  859.     (layout-menu-container ppin pw ph title tw th content cw ch)
  860.       (execute-layout self width height ppin pw1 ph1 title tw1 th1 content cw1 ch1))))
  861.  
  862. (defmethod preferred-size ((self menu-container) &key width height border-width)
  863.   (declare (ignore width height border-width))
  864.   (let* ((children (composite-children self))
  865.      (content (find :content children :key #'contact-name))
  866.      (title (find :menu-title children :key #'contact-name))
  867.      (ppin (find :pushpin children :key #'contact-name)))
  868.  
  869.     (MULTIPLE-VALUE-BIND (cw ch)
  870.     (preferred-size content :width 0 :height 0)
  871.       (MULTIPLE-VALUE-BIND (tw th)
  872.       (AND title (preferred-size title :width 0 :height 0))
  873.     (MULTIPLE-VALUE-BIND (pw ph)
  874.         (AND ppin (preferred-size ppin))
  875.       (MULTIPLE-VALUE-BIND (preferred-width preferred-height)
  876.           (layout-menu-container ppin pw ph title tw th content cw ch)
  877.         (VALUES preferred-width preferred-height 0)))))))
  878.  
  879. (defmethod manage-geometry ((self menu-container) child x y width height bw &key)
  880.   (let* ((children (composite-children self))
  881.        
  882.      (content (find :content children :key #'contact-name))
  883.      (cw (contact-width content))
  884.      (ch (contact-height content))
  885.        
  886.      (title (find :menu-title children :key #'contact-name))
  887.      (tw (and title (contact-width title)))
  888.      (th (and title (contact-height title)))
  889.        
  890.      (ppin (find :pushpin children :key #'contact-name))
  891.      (pw (and ppin (contact-width ppin)))
  892.      (ph (and ppin (contact-height ppin)))
  893.  
  894.      (x (or x (contact-x child)))
  895.      (y (or y (contact-y child)))
  896.      (width (or width (contact-width child)))
  897.      (height (or height (contact-height child))))
  898.  
  899.  
  900.     (multiple-value-bind (self-width self-height pw1 ph1 tw1 th1 cw1 ch1)
  901.     (cond
  902.       ((eq child content)
  903.        (cond
  904.          (title
  905.           ;; If there is a title then try to adjust it
  906.           (shrink/expand-title
  907.            title
  908.            pw
  909.            ph
  910.            (if pw (- width pw) width)
  911.            th
  912.            width
  913.            height
  914.            ;; If title adjust fails then try to adjust content
  915.            ;; so can at least offer compromise.
  916.            #'(lambda()
  917.            (shrink/expand-content
  918.             content
  919.             pw
  920.             ph
  921.             tw
  922.             th
  923.             (or (and pw (+ pw tw)) tw)
  924.             height
  925.             #'mcgm-disapprove))))
  926.          (ppin
  927.           ;; If ppin exists must make sure content is at least as wide
  928.           (if (> width pw)
  929.           (values (+ 2 width) (+ 2 height ph 1) pw ph tw th width height)
  930.           (shrink/expand-content
  931.            content
  932.            pw
  933.            ph
  934.            tw
  935.            th
  936.            pw
  937.            height
  938.            #'mcgm-disapprove)))
  939.          (t
  940.           ;; Menu has neither pushpin nor title
  941.           (values
  942.            (+ 2 width) (+ 2 height) pw ph tw th width height))))
  943.       ((eq child title)
  944.        (shrink/expand-content
  945.         content
  946.         pw
  947.         ph
  948.         width
  949.         height
  950.         (if ppin (+ pw tw) tw)
  951.         ch
  952.         #'(lambda()
  953.         (shrink/expand-title
  954.          title
  955.          pw
  956.          ph
  957.          (if ppin (- cw pw) width)
  958.          height
  959.          cw
  960.          ch
  961.          #'mcgm-disapprove))))
  962.       ;; It must be the pushpin which has changed
  963.       (title    
  964.        (shrink/expand-title
  965.         title
  966.         width
  967.         height
  968.         (- cw width)
  969.         th
  970.         cw
  971.         ch
  972.         #'(lambda()
  973.         (shrink/expand-content
  974.          content
  975.          width
  976.          height
  977.          tw
  978.          th
  979.          (+ width tw)
  980.          ch
  981.          #'mcgm-disapprove))))
  982.       ;; Pushpin is being managed, but no title to adjust, so must adjust content.
  983.       ((< cw width)
  984.        ;; If the content width is less than the requested pushpin width we try to
  985.        ;; shrink the content accordingly. (Pretty unlikely case, eh?)
  986.        (shrink/expand-content
  987.         content
  988.         width
  989.         height
  990.         tw
  991.         th
  992.         width
  993.         ch
  994.         #'mcgm-disapprove))
  995.       (t
  996.        ;; Else the content is at least as wide as the pushpin and we can simply
  997.        ;; accept the pushpin change without any ripple effects.
  998.        (values
  999.         (+ 2 cw) (+ 2 ch ph)
  1000.         width height
  1001.         tw th
  1002.         cw ch)))
  1003.  
  1004.       (and
  1005.        self-width                      ;Width = NIL implies failure without suggesting compromise.
  1006.        (multiple-value-bind (px1 py1 tx1 ty1 cx1 cy1)
  1007.        (locate-menu-components pw1 ph1 tw1 th1 self-width self)
  1008.      (let
  1009.          ((self-change-approved
  1010.            (or
  1011.         (and
  1012.          (= self-width (contact-width self))
  1013.          (= self-height (contact-height self)))
  1014.         (change-geometry self
  1015.                  :width self-width
  1016.                  :height self-height
  1017.                  :accept-p nil)))
  1018.           (approve-p
  1019.            (and
  1020.         (or (null bw) (= 0 bw))
  1021.         (cond
  1022.           ((eq child ppin) (and (= pw1 width) (= ph1 height)
  1023.                     (= px1 x)     (= py1 y)))
  1024.           ((eq child title) (and (= tw1 width) (= th1 height)
  1025.                      (= tx1 x)     (= ty1 y)
  1026.                      )
  1027.            )
  1028.           (t (and (= cw1 width) (= ch1 height)
  1029.               (= cx1 x)     (= cy1 y)))))))
  1030.        (and
  1031.         self-change-approved
  1032.         (progn
  1033.           (when approve-p
  1034.         (execute-layout
  1035.          self self-width self-height
  1036.          ppin pw1 ph1
  1037.          title tw1 th1
  1038.          content cw1 ch1))
  1039.           (cond
  1040.         ((eq child ppin) (values approve-p px1 py1 pw1 ph1 0))
  1041.         ((eq child title) (values approve-p tx1 ty1 tw1 th1 0))
  1042.         (t (values approve-p cx1 cy1 cw1 ch1 0)))))))))))
  1043.  
  1044.  
  1045.